home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / Cartiers-Contribs / Modules / extended-apropos / apropos.lisp next >
Encoding:
Text File  |  1992-09-08  |  4.8 KB  |  164 lines  |  [TEXT/CCL2]
  1. ;;; -*- package: CC -*-
  2. ;;;
  3. ;;;; An extended Apropos dialog
  4. ;;;
  5.  
  6.  
  7. (in-package "CC")
  8.  
  9.  
  10. (defvar *apropos* nil)
  11.  
  12. (defvar *apropos-width* 500)
  13. (defvar *apropos-minimum-height* 291)
  14. (defvar *apropos-symbols-width* 342)
  15. (defvar *apropos-body-height* 170)
  16.  
  17. (defvar *apropos-size* (make-point *apropos-width* *apropos-minimum-height*))
  18. (defvar *apropos-position* :centered)
  19.  
  20.  
  21. (defvar *working* nil)
  22.  
  23. (defvar *search-domain* :global)
  24. (defvar *update-frequency* 25)
  25.  
  26. (defvar *show-p* nil)
  27. (defvar *show-what* :value)
  28.  
  29. (defvar *default-package*
  30.   ;; Set this to NIL to get "all packages".
  31.   (find-package "CL-USER"))
  32.  
  33. (defvar *auto-search*
  34.   ;; If set to T, selecting a pop up menu
  35.   ;; will automatically do a search. Use the
  36.   ;; option key to toggle the behavior.
  37.   t)
  38.  
  39.  
  40. (defclass extended-apropos (apropos-hide-window)
  41.     ()
  42.   (:default-initargs
  43.     :window-title  "Apropos"
  44.     :window-type   :document-with-grow
  45.     :view-size     *apropos-size*
  46.     :view-position *apropos-position*
  47.     :view-subviews
  48.     (list
  49.       (make-instance 'help-button        :view-position #@(477   6))
  50.       (make-instance 'apropos-title      :view-position #@(  5   5))
  51.       (make-instance 'name-subview       :view-position #@( 15  28))
  52.       (make-instance 'criterion-subview  :view-position #@( 15  55))
  53.       (make-instance 'package-subview    :view-position #@(  5 106))
  54.       (make-instance 'heritage-subview   :view-position #@(  5 134))
  55.       (make-instance 'search-subview     :view-position #@(290 104))
  56.       (make-instance 'search-thermometer :view-position #@(482 181))
  57.       (make-instance 'action-subview     :view-position #@(353 176))
  58.       (make-instance 'symbols-table      :view-position #@(  0 170)
  59.                      :view-size (make-point *apropos-symbols-width*
  60.                                             (- (point-v *apropos-size*)
  61.                                                *apropos-body-height*))))))
  62.  
  63.  
  64. (defmethod help-string ((self extended-apropos))
  65.   (format nil "Use this window to search for symbols matching ~
  66.                certain specific criteria.~%~%~
  67.                Note: this window can be resized, don't be fooled ~
  68.                by the fact that the grow icon is not drawn.~%~%~
  69.                Note: you can use the copy menu item to copy the ~
  70.                selected symbol's name to the clipboard."))
  71.  
  72.  
  73. (defmethod view-cursor ((self extended-apropos) point)
  74.   (declare (ignore point))
  75.   (if *working*
  76.       *watch-cursor*
  77.     (call-next-method)))
  78.  
  79.  
  80. (defmethod view-draw-contents :after ((self extended-apropos))
  81.   (#_MoveTo   4  90) (#_LineTo 495  90)
  82.   (#_MoveTo 347 169) (#_LineTo 495 169)
  83.   (#_MoveTo 273  95) (#_LineTo 273 164))
  84.  
  85.  
  86. (defmethod window-draw-grow-icon ((self extended-apropos))
  87.   )
  88.  
  89.  
  90. (defmethod window-grow-rect ((self extended-apropos))
  91.   (make-record :rect
  92.     :left  (+ *apropos-width* 1) :top *apropos-minimum-height*
  93.     :right (+ *apropos-width* 1) :bottom 20000))
  94.  
  95.  
  96. (defmethod set-view-size :after ((self extended-apropos) h &optional v)
  97.   (when (null v)
  98.     (setf v (point-v h)
  99.           h (point-h h)))
  100.   (set-view-size (apropos-view 'symbols-table)
  101.                  *apropos-symbols-width* (- v *apropos-body-height*)))
  102.  
  103.  
  104. (defmethod view-key-event-handler ((self extended-apropos) char)
  105.   (if (or (eql char #\UpArrow)
  106.           (eql char #\DownArrow))
  107.       (let ((table (apropos-view 'symbols-table)))
  108.         (let ((cell (first (selected-cells table))))
  109.           (when cell
  110.             (let ((next (case char
  111.                           (#\UpArrow   (- (point-v cell) 1))
  112.                           (#\DownArrow (+ (point-v cell) 1)))))
  113.               (when (and (>= next 0)
  114.                          (< next (point-v (table-dimensions table))))
  115.                 (cell-deselect table 0 (point-v cell))
  116.                 (cell-select table 0 next)
  117.                 (when (null (cell-position table 0 next))
  118.                   (scroll-to-cell table 0 next)))))
  119.           (able-action-buttons)))
  120.     (call-next-method)))
  121.  
  122.  
  123. (defun make-or-show-extended-apropos ()
  124.   (cond ((or (null *apropos*)
  125.              (null (wptr *apropos*)))
  126.          (setf *search-domain* :global)
  127.          (setf *show-p* nil *show-what* :value)
  128.          (setf *apropos* (make-instance 'extended-apropos)))
  129.         (t
  130.          (reinstall-package-menu)
  131.          (window-select *apropos*)))
  132.   (select-all (apropos-view 'name-text)))
  133.  
  134.  
  135. (defmethod copy ((self extended-apropos))
  136.   (put-scrap :text (string-downcase (symbol-name (selected-symbol)))))
  137.  
  138.  
  139. (defun apropos-view (name)
  140.   (find-view *apropos*
  141.              name))
  142.  
  143.  
  144. ;;;
  145. ;;;; Installing the Extended Apropos
  146. ;;;
  147.  
  148.  
  149. (set-menu-item-action-function (find-menu-item (find-menu "Tools")
  150.                                                "Apropos")
  151.   'make-or-show-extended-apropos)
  152.  
  153.  
  154. ;;;
  155. ;;;; Cleaning Up
  156. ;;;
  157.  
  158.  
  159. (defun forget-extended-apropos ()
  160.   (setq *apropos* nil))
  161.  
  162. (push 'forget-extended-apropos
  163.       *save-exit-functions*)
  164.